home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue50 / Alfresco / TstBinTr.dpr < prev   
Encoding:
Text File  |  1999-09-04  |  7.1 KB  |  273 lines
  1. program TstBinTr;
  2.  
  3. {$APPTYPE CONSOLE}
  4.  
  5. uses
  6.   SysUtils,
  7.   Classes,
  8.   AABinTre in 'AABinTre.pas',
  9.   PSProcs in 'PSProcs.pas';
  10.  
  11. const
  12.   ColumnWidth = 25;
  13.   StripHeight = 25;
  14.   MarginLeft  = 20;
  15.  
  16. type
  17.   PMyRec = ^TMyRec;
  18.   TMyRec = packed record
  19.     Name : string[31];
  20.     Age  : integer;
  21.   end;
  22.  
  23. function CompareMyRec(aItem1, aItem2 : pointer) : integer;
  24. var
  25.   MyRec1 : PMyRec absolute aItem1;
  26.   MyRec2 : PMyRec absolute aItem2;
  27. begin
  28.   if (MyRec1.Name < MyRec2.Name) then
  29.     Result := -1
  30.   else if (MyRec1.Name > MyRec2.Name) then
  31.     Result := 1
  32.   else
  33.     Result := MyRec1.Age - MyRec2.Age;
  34. end;
  35.  
  36. procedure RandomMyRec(var MyRec : TMyRec);
  37. var
  38.   i : integer;
  39. begin
  40.   MyRec.Name[0] := #3 {char(Random(3) + 1)};
  41.   for i := 1 to length(MyRec.Name) do
  42.     MyRec.Name[i] := char(Random(26) + ord('a'));
  43.   MyRec.Age := Random(20) + 30;
  44. end;
  45.  
  46. procedure DisposeMyRec(aItem : pointer);
  47. begin
  48.   Dispose(PMyRec(aItem));
  49. end;
  50.  
  51. function PrintItem(aNode      : PaaBTNode;
  52.                    aExtraData : pointer) : boolean;
  53. begin
  54.   writeln(PMyRec(aNode^.btData)^.Name);
  55.   Result := true;
  56. end;
  57.  
  58. function CheckItem(aNode      : PaaBTNode;
  59.                    aExtraData : pointer) : boolean;
  60. begin
  61.   if (aNode^.btChild[false] <> nil) then
  62.     if aNode^.btChild[false]^.btParent <> aNode then
  63.       raise Exception.Create('node error');
  64.   if (aNode^.btChild[true] <> nil) then
  65.     if aNode^.btChild[true]^.btParent <> aNode then
  66.       raise Exception.Create('node error');
  67.   Result := true;
  68. end;
  69.  
  70.  
  71. procedure DrawNode(aNode   : PaaBTNode;
  72.                    aStrip  : integer;
  73.                    aColumn : integer;
  74.                    aParentStrip  : integer;
  75.                    aParentColumn : integer;
  76.                    aExtraData    : pointer); far;
  77. var
  78.   X, Y : integer;
  79.   ParentX, ParentY : integer;
  80.   HasParent : boolean;
  81. begin
  82.   {calculate the X, Y position of the bottom left corner of the box}
  83.   X := MarginLeft + aColumn * ColumnWidth;
  84.   Y := 720 - (aStrip * StripHeight);
  85.   {do the same for the parent box}
  86.   if (aParentStrip = -1) then begin
  87.     HasParent := false;
  88.     ParentX := -1;
  89.     ParentY := -1;
  90.   end
  91.   else begin
  92.     HasParent := true;
  93.     ParentX := MarginLeft + aParentColumn * ColumnWidth;
  94.     ParentY := 720 - (aParentStrip * StripHeight);
  95.   end;
  96.   {if the node is red, draw a filled box}
  97.   if (aNode^.btColor = aaRed) then
  98.     AAPSDrawRectFill(TStringList(aExtraData),
  99.                      X, Y, ColumnWidth, StripHeight - 10, 0.9)
  100.   {otherwise draw the box for the node}
  101.   else
  102.     AAPSDrawRect(TStringList(aExtraData),
  103.                  X, Y, ColumnWidth, StripHeight - 10);
  104.   {draw the text for the node}
  105.   AAPSDrawText(TStringList(aExtraData),
  106.                PMyRec(aNode^.btData)^.Name,
  107.                X+3, Y+5, 10);
  108.   {draw a line from our parent to ourselves}
  109.   if HasParent then begin
  110.     AAPSDrawLine(TStringList(aExtraData),
  111.                  ParentX + (ColumnWidth div 2),
  112.                  ParentY,
  113.                  X + (ColumnWidth div 2),
  114.                  Y + (StripHeight - 10));
  115.   end;
  116. end;
  117.  
  118.  
  119. procedure DrawTestTree(aBinTree : TaaBinarySearchTree;
  120.                        aID      : integer);
  121. var
  122.   SList : TStringList;
  123. begin
  124.   SList := TStringList.Create;
  125.   try
  126.     AAPSOutputProlog(SList);
  127.     DrawBinaryTree(aBinTree, DrawNode, pointer(SList));
  128.     AAPSOutputEpilog(SList);
  129.     SList.SaveToFile(Format('BinTre%d.EPS', [aID]));
  130.   finally
  131.     SList.Free;
  132.   end;
  133. end;
  134.  
  135. const
  136.   NodeCount = 15;
  137. var
  138.   BinTree : TaaRedBlackTree{BinarySearchTree};
  139.   MyRec   : PMyRec;
  140.   i       : integer;
  141.   MyRecQuery : TMyRec;
  142. begin
  143.   writeln('Testing binary tree...');
  144.   try
  145.     BinTree := TaaRedBlackTree{BinarySearchTree}.Create(CompareMyRec, DisposeMyRec);
  146.     try
  147.       writeln('inserting');
  148.       RandSeed := $12345678;
  149.       for i := 1 to NodeCount do begin
  150.         New(MyRec);
  151.         RandomMyRec(MyRec^);
  152.         BinTree.Insert(MyRec);
  153.         DrawTestTree(BinTree, i);
  154.       end;
  155.       writeln('--pre-order');
  156.       BinTree.Traverse(tmPreOrder, PrintItem, nil, true);
  157.       readln;
  158.       writeln('--in-order');
  159.       BinTree.Traverse(tmInOrder, PrintItem, nil, true);
  160.       readln;
  161.       writeln('--post-order');
  162.       BinTree.Traverse(tmPostOrder, PrintItem, nil, true);
  163.       readln;
  164.       writeln('--level-order');
  165.       BinTree.Traverse(tmLevelOrder, PrintItem, nil, true);
  166.       readln;
  167.  
  168.       RandSeed := $12345678;
  169.       for i := 1 to NodeCount do begin
  170.         RandomMyRec(MyRecQuery);
  171.         MyRec := BinTree.Find(@MyRecQuery);
  172.         if (MyRec = nil) or (MyRec^.Name <> MyRecQuery.Name) then
  173.           writeln('error: cannot find ', MyRecQuery.Name);
  174.       end;
  175.  
  176.       writeln('deleting');
  177.       RandSeed := $12345678;
  178.       for i := 1 to NodeCount do begin
  179.         RandomMyRec(MyRecQuery);
  180.         if Odd(i) then begin
  181.           BinTree.Delete(@MyRecQuery);
  182.           DrawTestTree(BinTree, i+20);
  183.         end;
  184.       end;
  185.       RandSeed := $12345678;
  186.       for i := 1 to NodeCount do begin
  187.         RandomMyRec(MyRecQuery);
  188.         if not Odd(i) then begin
  189.           BinTree.Delete(@MyRecQuery);
  190.           BinTree.Traverse(tmInOrder, CheckItem, nil, true);
  191.           DrawTestTree(BinTree, i+40);
  192.         end;
  193.       end;
  194.  
  195.       {generate degenerate trees}
  196.       BinTree.Clear;
  197.       New(MyRec);
  198.       MyRec^.Name := '  a ';
  199.       BinTree.Insert(MyRec);
  200.       New(MyRec);
  201.       MyRec^.Name := '  b ';
  202.       BinTree.Insert(MyRec);
  203.       New(MyRec);
  204.       MyRec^.Name := '  c ';
  205.       BinTree.Insert(MyRec);
  206.       New(MyRec);
  207.       MyRec^.Name := '  d ';
  208.       BinTree.Insert(MyRec);
  209.       New(MyRec);
  210.       MyRec^.Name := '  e ';
  211.       BinTree.Insert(MyRec);
  212.       New(MyRec);
  213.       MyRec^.Name := '  f ';
  214.       BinTree.Insert(MyRec);
  215.       DrawTestTree(BinTree, 90);
  216.  
  217.       BinTree.Clear;
  218.       New(MyRec);
  219.       MyRec^.Name := '  a ';
  220.       BinTree.Insert(MyRec);
  221.       New(MyRec);
  222.       MyRec^.Name := '  f ';
  223.       BinTree.Insert(MyRec);
  224.       New(MyRec);
  225.       MyRec^.Name := '  b ';
  226.       BinTree.Insert(MyRec);
  227.       New(MyRec);
  228.       MyRec^.Name := '  e ';
  229.       BinTree.Insert(MyRec);
  230.       New(MyRec);
  231.       MyRec^.Name := '  c ';
  232.       BinTree.Insert(MyRec);
  233.       New(MyRec);
  234.       MyRec^.Name := '  d ';
  235.       BinTree.Insert(MyRec);
  236.       DrawTestTree(BinTree, 91);
  237.  
  238.       {generate bushy tree}
  239.       BinTree.Clear;
  240.       New(MyRec);
  241.       MyRec^.Name := '  d ';
  242.       BinTree.Insert(MyRec);
  243.       New(MyRec);
  244.       MyRec^.Name := '  b ';
  245.       BinTree.Insert(MyRec);
  246.       New(MyRec);
  247.       MyRec^.Name := '  f ';
  248.       BinTree.Insert(MyRec);
  249.       New(MyRec);
  250.       MyRec^.Name := '  a ';
  251.       BinTree.Insert(MyRec);
  252.       New(MyRec);
  253.       MyRec^.Name := '  c ';
  254.       BinTree.Insert(MyRec);
  255.       New(MyRec);
  256.       MyRec^.Name := '  e ';
  257.       BinTree.Insert(MyRec);
  258.       New(MyRec);
  259.       MyRec^.Name := '  g ';
  260.       BinTree.Insert(MyRec);
  261.       DrawTestTree(BinTree, 92);
  262.  
  263.     finally
  264.       BinTree.Free;
  265.     end;
  266.   except
  267.     on E: Exception do
  268.       writeln(E.Message);
  269.   end;
  270.   writeln('Done');
  271.   readln;
  272. end.
  273.